Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume10/xlisp21/part08

Text File | 1990-02-26 | 57.7 KB | 2,506 lines

Newsgroups: comp.sources.misc
organization: Cognos Inc., Ottawa, Canada
subject: v10i095: XLisP 2.1 sources 4b (2/2) / 5
From: [e-mail] (Gary Murphy)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 10, Issue 95
Submitted-by: [e-mail] (Gary Murphy)
Archive-name: xlisp21/part08

#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    xlread.c
#    xlstr.c
#    xlstruct.c
#    xlsubr.c
#    xlsym.c
#    xlsys.c
# This archive created: Sun Feb 18 23:40:39 1990
# By:    Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlread.c'" '(17573 characters)'
if test -f 'xlread.c'
then
    echo shar: over-writing existing file "'xlread.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlread.c'
X/* xlread - xlisp expression input routine */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* symbol parser modes */
X#define DONE    0
X#define NORMAL    1
X#define ESCAPE    2
X
X/* external variables */
Xextern LVAL s_stdout,true,s_dot;
Xextern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
Xextern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
Xextern LVAL k_sescape,k_mescape;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *osaopen();
Xextern double atof();
Xextern ITYPE;
X
X#define WSPACE "\t \f\r\n"
X#define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
X#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
X
X/* forward declarations */
XFORWARD LVAL callmacro();
XFORWARD LVAL psymbol(),punintern();
XFORWARD LVAL pnumber(),pquote(),plist(),pvector(),pstruct();
XFORWARD LVAL readlist(),tentry();
X
X/* xlload - load a file of xlisp expressions */
Xint xlload(fname,vflag,pflag)
X  char *fname; int vflag,pflag;
X{
X    char fullname[STRMAX+1];
X    LVAL fptr,expr;
X    CONTEXT cntxt;
X    FILE *fp;
X    int sts;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fptr);
X    xlsave(expr);
X
X    /* default the extension */
X    if (needsextension(fname)) {
X    strcpy(fullname,fname);
X    strcat(fullname,".lsp");
X    fname = fullname;
X    }
X
X    /* allocate a file node */
X    fptr = cvfile(NULL);
X
X    /* open the file */
X    if ((fp = osaopen(fname,"r")) == NULL) {
X    xlpopn(2);
X    return (FALSE);
X    }
X    setfile(fptr,fp);
X
X    /* print the information line */
X    if (vflag)
X    { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
X
X    /* read, evaluate and possibly print each expression in the file */
X    xlbegin(&cntxt,CF_ERROR,true);
X    if (setjmp(cntxt.c_jmpbuf))
X    sts = FALSE;
X    else {
X    while (xlread(fptr,&expr,FALSE)) {
X        expr = xleval(expr);
X        if (pflag)
X        stdprint(expr);
X    }
X    sts = TRUE;
X    }
X    xlend(&cntxt);
X
X    /* close the file */
X    osclose(getfile(fptr));
X    setfile(fptr,NULL);
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return status */
X    return (sts);
X}
X
X/* xlread - read an xlisp expression */
Xint xlread(fptr,pval,rflag)
X  LVAL fptr,*pval; int rflag;
X{
X    int sts;
X
X    /* read an expression */
X    while ((sts = readone(fptr,pval)) == FALSE)
X    ;
X
X    /* return status */
X    return (sts == EOF ? FALSE : TRUE);
X}
X
X/* readone - attempt to read a single expression */
Xint readone(fptr,pval)
X  LVAL fptr,*pval;
X{
X    LVAL val,type;
X    int ch;
X
X    /* get a character and check for EOF */
X    if ((ch = xlgetc(fptr)) == EOF)
X    return (EOF);
X
X    /* handle white space */
X    if ((type = tentry(ch)) == k_wspace)
X    return (FALSE);
X
X    /* handle symbol constituents */
X    else if (type == k_const) {
X    xlungetc(fptr,ch);
X    *pval = psymbol(fptr);
X    return (TRUE);
X    }
X
X    /* handle single and multiple escapes */
X    else if (type == k_sescape || type == k_mescape) {
X    xlungetc(fptr,ch);
X    *pval = psymbol(fptr);
X    return (TRUE);
X    }
X
X    /* handle read macros */
X    else if (consp(type)) {
X    if ((val = callmacro(fptr,ch)) && consp(val)) {
X        *pval = car(val);
X        return (TRUE);
X    }
X    else
X        return (FALSE);
X    }
X
X    /* handle illegal characters */
X    else
X    xlerror("illegal character",cvfixnum((FIXTYPE)ch));
X}
X
X/* rmhash - read macro for '#' */
XLVAL rmhash()
X{
X    LVAL fptr,mch,val;
X    int escflag,ch;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* make the return value */
X    val = consa(NIL);
X
X    /* check the next character */
X    switch (ch = xlgetc(fptr)) {
X    case '\'':
X        rplaca(val,pquote(fptr,s_function));
X        break;
X    case '(':
X        xlungetc(fptr,ch);
X        rplaca(val,pvector(fptr));
X        break;
X    case 'b':
X    case 'B':
X        rplaca(val,pnumber(fptr,2));
X        break;
X    case 'o':
X    case 'O':
X        rplaca(val,pnumber(fptr,8));
X        break;
X    case 'x':
X    case 'X':
X            rplaca(val,pnumber(fptr,16));
X        break;
X    case 's':
X    case 'S':
X        rplaca(val,pstruct(fptr));
X        break;
X    case '\\':
X        xlungetc(fptr,ch);
X        pname(fptr,&escflag);
X        ch = buf[0];
X        if (strlen(buf) > 1) {
X            upcase(buf);
X            if (strcmp(buf,"NEWLINE") == 0)
X            ch = '\n';
X            else if (strcmp(buf,"SPACE") == 0)
X            ch = ' ';
X            else
X            xlerror("unknown character name",cvstring(buf));
X        }
X        rplaca(val,cvchar(ch));
X        break;
X    case ':':
X            rplaca(val,punintern(fptr));
X        break;
X    case '|':
X            pcomment(fptr);
X        val = NIL;
X        break;
X    default:
X        xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value */
X    return (val);
X}
X
X/* rmquote - read macro for '\'' */
XLVAL rmquote()
X{
X    LVAL fptr,mch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* parse the quoted expression */
X    return (consa(pquote(fptr,s_quote)));
X}
X
X/* rmdquote - read macro for '"' */
XLVAL rmdquote()
X{
X    unsigned char buf[STRMAX+1],*p,*sptr;
X    LVAL fptr,str,newstr,mch;
X    int len,blen,ch,d2,d3;
X
X    /* protect some pointers */
X    xlsave1(str);
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* loop looking for a closing quote */
X    len = blen = 0; p = buf;
X    while ((ch = checkeof(fptr)) != '"') {
X
X    /* handle escaped characters */
X    switch (ch) {
X    case '\\':
X        switch (ch = checkeof(fptr)) {
X        case 't':
X            ch = '\011';
X            break;
X        case 'n':
X            ch = '\012';
X            break;
X        case 'f':
X            ch = '\014';
X            break;
X        case 'r':
X            ch = '\015';
X            break;
X        default:
X            if (ch >= '0' && ch <= '7') {
X                d2 = checkeof(fptr);
X                d3 = checkeof(fptr);
X                if (d2 < '0' || d2 > '7'
X                 || d3 < '0' || d3 > '7')
X                xlfail("invalid octal digit");
X                ch -= '0'; d2 -= '0'; d3 -= '0';
X                ch = (ch << 6) | (d2 << 3) | d3;
X            }
X            break;
X        }
X    }
X
X    /* check for buffer overflow */
X    if (blen >= STRMAX) {
X         newstr = newstring(len + STRMAX + 1);
X        sptr = getstring(newstr); *sptr = '\0';
X        if (str) strcat(sptr,getstring(str));
X        *p = '\0'; strcat(sptr,buf);
X        p = buf; blen = 0;
X        len += STRMAX;
X        str = newstr;
X    }
X
X    /* store the character */
X    *p++ = ch; ++blen;
X    }
X
X    /* append the last substring */
X    if (str == NIL || blen) {
X    newstr = newstring(len + blen + 1);
X    sptr = getstring(newstr); *sptr = '\0';
X    if (str) strcat(sptr,getstring(str));
X    *p = '\0'; strcat(sptr,buf);
X    str = newstr;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new string */
X    return (consa(str));
X}
X
X/* rmbquote - read macro for '`' */
XLVAL rmbquote()
X{
X    LVAL fptr,mch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* parse the quoted expression */
X    return (consa(pquote(fptr,s_bquote)));
X}
X
X/* rmcomma - read macro for ',' */
XLVAL rmcomma()
X{
X    LVAL fptr,mch,sym;
X    int ch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* check the next character */
X    if ((ch = xlgetc(fptr)) == '@')
X    sym = s_comat;
X    else {
X    xlungetc(fptr,ch);
X    sym = s_comma;
X    }
X
X    /* make the return value */
X    return (consa(pquote(fptr,sym)));
X}
X
X/* rmlpar - read macro for '(' */
XLVAL rmlpar()
X{
X    LVAL fptr,mch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* make the return value */
X    return (consa(plist(fptr)));
X}
X
X/* rmrpar - read macro for ')' */
XLVAL rmrpar()
X{
X    xlfail("misplaced right paren");
X}
X
X/* rmsemi - read macro for ';' */
XLVAL rmsemi()
X{
X    LVAL fptr,mch;
X    int ch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* skip to end of line */
X    while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
X    ;
X
X    /* return nil (nothing read) */
X    return (NIL);
X}
X
X/* pcomment - parse a comment delimited by #| and |# */
XLOCAL pcomment(fptr)
X  LVAL fptr;
X{
X    int lastch,ch,n;
X
X    /* look for the matching delimiter (and handle nesting) */
X    for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
X    if (lastch == '|' && ch == '#')
X        { --n; ch = -1; }
X    else if (lastch == '#' && ch == '|')
X        { ++n; ch = -1; }
X    lastch = ch;
X    }
X}
X
X/* pnumber - parse a number */
XLOCAL LVAL pnumber(fptr,radix)
X  LVAL fptr; int radix;
X{
X    int digit,ch;
X    long num;
X
X    for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
X    if (islower(ch)) ch = toupper(ch);
X    if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
X        break;
X    if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
X        break;
X    num = num * (long)radix + (long)digit;
X    }
X    xlungetc(fptr,ch);
X    return (cvfixnum((FIXTYPE)num));
X}
X
X/* plist - parse a list */
XLOCAL LVAL plist(fptr)
X  LVAL fptr;
X{
X    LVAL val,expr,lastnptr,nptr;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(val);
X    xlsave(expr);
X
X    /* keep appending nodes until a closing paren is found */
X    for (lastnptr = NIL; nextch(fptr) != ')'; )
X
X    /* get the next expression */
X    switch (readone(fptr,&expr)) {
X    case EOF:
X        badeof(fptr);
X    case TRUE:
X
X        /* check for a dotted tail */
X        if (expr == s_dot) {
X
X        /* make sure there's a node */
X        if (lastnptr == NIL)
X            xlfail("invalid dotted pair");
X
X        /* parse the expression after the dot */
X        if (!xlread(fptr,&expr,TRUE))
X            badeof(fptr);
X        rplacd(lastnptr,expr);
X
X        /* make sure its followed by a close paren */
X        if (nextch(fptr) != ')')
X            xlfail("invalid dotted pair");
X        }
X
X        /* otherwise, handle a normal list element */
X        else {
X        nptr = consa(expr);
X        if (lastnptr == NIL)
X            val = nptr;
X        else
X            rplacd(lastnptr,nptr);
X        lastnptr = nptr;
X        }
X        break;
X    }
X
X    /* skip the closing paren */
X    xlgetc(fptr);
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return successfully */
X    return (val);
X}
X
X/* pvector - parse a vector */
XLOCAL LVAL pvector(fptr)
X  LVAL fptr;
X{
X    LVAL list,val;
X    int len,i;
X
X    /* protect some pointers */
X    xlsave1(list);
X
X    /* read the list */
X    list = readlist(fptr,&len);
X
X    /* make a vector of the appropriate length */
X    val = newvector(len);
X
X    /* copy the list into the vector */
X    for (i = 0; i < len; ++i, list = cdr(list))
X    setelement(val,i,car(list));
X
X    /* restore the stack */
X    xlpop();
X
X    /* return successfully */
X    return (val);
X}
X
X/* pstruct - parse a structure */
XLOCAL LVAL pstruct(fptr)
X  LVAL fptr;
X{
X    extern LVAL xlrdstruct();
X    LVAL list,val;
X    int len;
X
X    /* protect some pointers */
X    xlsave1(list);
X
X    /* read the list */
X    list = readlist(fptr,&len);
X
X    /* make the structure */
X    val = xlrdstruct(list);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return successfully */
X    return (val);
X}
X
X/* pquote - parse a quoted expression */
XLOCAL LVAL pquote(fptr,sym)
X  LVAL fptr,sym;
X{
X    LVAL val,p;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* allocate two nodes */
X    val = consa(sym);
X    rplacd(val,consa(NIL));
X
X    /* initialize the second to point to the quoted expression */
X    if (!xlread(fptr,&p,TRUE))
X    badeof(fptr);
X    rplaca(cdr(val),p);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the quoted expression */
X    return (val);
X}
X
X/* psymbol - parse a symbol name */
XLOCAL LVAL psymbol(fptr)
X  LVAL fptr;
X{
X    int escflag;
X    LVAL val;
X    pname(fptr,&escflag);
X    return (escflag || !isnumber(buf,&val) ? xlenter(buf) : val);
X}
X
X/* punintern - parse an uninterned symbol */
XLOCAL LVAL punintern(fptr)
X  LVAL fptr;
X{
X    int escflag;
X    pname(fptr,&escflag);
X    return (xlmakesym(buf));
X}
X
X/* pname - parse a symbol/package name */
XLOCAL int pname(fptr,pescflag)
X  LVAL fptr; int *pescflag;
X{
X    int mode,ch,i;
X    LVAL type;
X
X    /* initialize */
X    *pescflag = FALSE;
X    mode = NORMAL;
X    i = 0;
X
X    /* accumulate the symbol name */
X    while (mode != DONE) {
X
X    /* handle normal mode */
X    while (mode == NORMAL)
X        if ((ch = xlgetc(fptr)) == EOF)
X        mode = DONE;
X        else if ((type = tentry(ch)) == k_sescape) {
X        i = storech(buf,i,checkeof(fptr));
X        *pescflag = TRUE;
X        }
X        else if (type == k_mescape) {
X        *pescflag = TRUE;
X        mode = ESCAPE;
X        }
X        else if (type == k_const
X         ||  (consp(type) && car(type) == k_nmacro))
X        i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
X        else
X        mode = DONE;
X
X    /* handle multiple escape mode */
X    while (mode == ESCAPE)
X        if ((ch = xlgetc(fptr)) == EOF)
X        badeof(fptr);
X        else if ((type = tentry(ch)) == k_sescape)
X        i = storech(buf,i,checkeof(fptr));
X        else if (type == k_mescape)
X        mode = NORMAL;
X        else
X        i = storech(buf,i,ch);
X    }
X    buf[i] = 0;
X
X    /* check for a zero length name */
X    if (i == 0)
X    xlerror("zero length name");
X
X    /* unget the last character and return it */
X    xlungetc(fptr,ch);
X    return (ch);
X}
X
X/* readlist - read a list terminated by a ')' */
XLOCAL LVAL readlist(fptr,plen)
X  LVAL fptr; int *plen;
X{
X    LVAL list,expr,lastnptr,nptr;
X    int ch;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(list);
X    xlsave(expr);
X
X    /* get the open paren */
X    if ((ch = nextch(fptr)) != '(')
X    xlfail("expecting an open paren");
X    xlgetc(fptr);
X
X    /* keep appending nodes until a closing paren is found */
X    for (lastnptr = NIL, *plen = 0; (ch = nextch(fptr)) != ')'; ) {
X
X    /* check for end of file */
X    if (ch == EOF)
X        badeof(fptr);
X
X    /* get the next expression */
X    switch (readone(fptr,&expr)) {
X    case EOF:
X        badeof(fptr);
X    case TRUE:
X        nptr = consa(expr);
X        if (lastnptr == NIL)
X        list = nptr;
X        else
X        rplacd(lastnptr,nptr);
X        lastnptr = nptr;
X        ++(*plen);
X        break;
X    }
X    }
X
X    /* skip the closing paren */
X    xlgetc(fptr);
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the list */
X    return (list);
X}
X
X/* storech - store a character in the print name buffer */
XLOCAL int storech(buf,i,ch)
X  char *buf; int i,ch;
X{
X    if (i < STRMAX)
X    buf[i++] = ch;
X    return (i);
X}
X
X/* tentry - get a readtable entry */
XLVAL tentry(ch)
X  int ch;
X{
X    LVAL rtable;
X    rtable = getvalue(s_rtable);
X    if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
X    return (NIL);
X    return (getelement(rtable,ch));
X}
X
X/* nextch - look at the next non-blank character */
XLOCAL int nextch(fptr)
X  LVAL fptr;
X{
X    int ch;
X
X    /* return and save the next non-blank character */
X    while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
X    ;
X    xlungetc(fptr,ch);
X    return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X  LVAL fptr;
X{
X    int ch;
X
X    if ((ch = xlgetc(fptr)) == EOF)
X    badeof(fptr);
X    return (ch);
X}
X
X/* badeof - unexpected eof */
XLOCAL badeof(fptr)
X  LVAL fptr;
X{
X    xlgetc(fptr);
X    xlfail("unexpected EOF");
X}
X
X/* isnumber - check if this string is a number */
Xint isnumber(str,pval)
X  char *str; LVAL *pval;
X{
X    int dl,dr;
X    char *p;
X
X    /* initialize */
X    p = str; dl = dr = 0;
X
X    /* check for a sign */
X    if (*p == '+' || *p == '-')
X    p++;
X
X    /* check for a string of digits */
X    while (isdigit(*p))
X    p++, dl++;
X
X    /* check for a decimal point */
X    if (*p == '.') {
X    p++;
X    while (isdigit(*p))
X        p++, dr++;
X    }
X
X    /* check for an exponent */
X    if ((dl || dr) && *p == 'E') {
X    p++;
X
X    /* check for a sign */
X    if (*p == '+' || *p == '-')
X        p++;
X
X    /* check for a string of digits */
X    while (isdigit(*p))
X        p++, dr++;
X    }
X
X    /* make sure there was at least one digit and this is the end */
X    if ((dl == 0 && dr == 0) || *p)
X    return (FALSE);
X
X    /* convert the string to an integer and return successfully */
X    if (pval) {
X    if (*str == '+') ++str;
X    if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X    *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
X    }
X    return (TRUE);
X}
X
X/* defmacro - define a read macro */
Xdefmacro(ch,type,offset)
X  int ch; LVAL type; int offset;
X{
X    extern FUNDEF funtab[];
X    LVAL subr;
X    subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
X    setelement(getvalue(s_rtable),ch,cons(type,subr));
X}
X
X/* callmacro - call a read macro */
XLVAL callmacro(fptr,ch)
X  LVAL fptr; int ch;
X{
X    LVAL *newfp;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(cdr(getelement(getvalue(s_rtable),ch)));
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(fptr);
X    pusharg(cvchar(ch));
X    xlfp = newfp;
X    return (xlapply(2));
X}
X
X/* upcase - translate a string to upper case */
XLOCAL upcase(str)
X  unsigned char *str;
X{
X    for (; *str != '\0'; ++str)
X    if (islower(*str))
X        *str = toupper(*str);
X}
X
X/* xlrinit - initialize the reader */
Xxlrinit()
X{
X    LVAL rtable;
X    char *p;
X    int ch;
X
X    /* create the read table */
X    rtable = newvector(256);
X    setvalue(s_rtable,rtable);
X
X    /* initialize the readtable */
X    for (p = WSPACE; ch = *p++; )
X    setelement(rtable,ch,k_wspace);
X    for (p = CONST1; ch = *p++; )
X    setelement(rtable,ch,k_const);
X    for (p = CONST2; ch = *p++; )
X    setelement(rtable,ch,k_const);
X
X    /* setup the escape characters */
X    setelement(rtable,'\\',k_sescape);
X    setelement(rtable,'|', k_mescape);
X
X    /* install the read macros */
X    defmacro('#', k_nmacro,FT_RMHASH);
X    defmacro('\'',k_tmacro,FT_RMQUOTE);
X    defmacro('"', k_tmacro,FT_RMDQUOTE);
X    defmacro('`', k_tmacro,FT_RMBQUOTE);
X    defmacro(',', k_tmacro,FT_RMCOMMA);
X    defmacro('(', k_tmacro,FT_RMLPAR);
X    defmacro(')', k_tmacro,FT_RMRPAR);
X    defmacro(';', k_tmacro,FT_RMSEMI);
X}
X
SHAR_EOF
if test 17573 -ne "`wc -c 'xlread.c'`"
then
    echo shar: error transmitting "'xlread.c'" '(should have been 17573 characters)'
fi
echo shar: extracting "'xlstr.c'" '(13099 characters)'
if test -f 'xlstr.c'
then
    echo shar: over-writing existing file "'xlstr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlstr.c'
X/* xlstr - xlisp string and character built-in functions */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* local definitions */
X#define fix(n)    cvfixnum((FIXTYPE)(n))
X#define TLEFT    1
X#define TRIGHT    2
X
X/* external variables */
Xextern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
Xextern LVAL true;
Xextern char buf[];
X
X/* external procedures */
Xextern char *strcat();
X
X/* forward declarations */
XFORWARD LVAL strcompare();
XFORWARD LVAL chrcompare();
XFORWARD LVAL changecase();
XFORWARD LVAL trim();
X
X/* string comparision functions */
XLVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */
XLVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */
XLVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */
XLVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */
XLVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */
XLVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */
X
X/* string comparison functions (not case sensitive) */
XLVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */
XLVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */
XLVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */
XLVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */
XLVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */
XLVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */
X
X/* strcompare - compare strings */
XLOCAL LVAL strcompare(fcn,icase)
X  int fcn,icase;
X{
X    int start1,end1,start2,end2,ch1,ch2;
X    unsigned char *p1,*p2;
X    LVAL str1,str2;
X
X    /* get the strings */
X    str1 = xlgastring();
X    str2 = xlgastring();
X
X    /* get the substring specifiers */
X    getbounds(str1,k_1start,k_1end,&start1,&end1);
X    getbounds(str2,k_2start,k_2end,&start2,&end2);
X
X    /* setup the string pointers */
X    p1 = &getstring(str1)[start1];
X    p2 = &getstring(str2)[start2];
X
X    /* compare the strings */
X    for (; start1 < end1 && start2 < end2; ++start1,++start2) {
X    ch1 = *p1++;
X    ch2 = *p2++;
X    if (icase) {
X        if (isupper(ch1)) ch1 = tolower(ch1);
X        if (isupper(ch2)) ch2 = tolower(ch2);
X    }
X    if (ch1 != ch2)
X        switch (fcn) {
X        case '<':    return (ch1 < ch2 ? fix(start1) : NIL);
X        case 'L':    return (ch1 <= ch2 ? fix(start1) : NIL);
X        case '=':    return (NIL);
X        case '#':    return (fix(start1));
X        case 'G':    return (ch1 >= ch2 ? fix(start1) : NIL);
X        case '>':    return (ch1 > ch2 ? fix(start1) : NIL);
X        }
X    }
X
X    /* check the termination condition */
X    switch (fcn) {
X    case '<':    return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
X    case 'L':    return (start1 >= end1 ? fix(start1) : NIL);
X    case '=':    return (start1 >= end1 && start2 >= end2 ? true : NIL);
X    case '#':    return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
X    case 'G':    return (start2 >= end2 ? fix(start1) : NIL);
X    case '>':    return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
X    }
X}
X
X/* case conversion functions */
XLVAL xupcase()   { return (changecase('U',FALSE)); }
XLVAL xdowncase() { return (changecase('D',FALSE)); }
X
X/* destructive case conversion functions */
XLVAL xnupcase()   { return (changecase('U',TRUE)); }
XLVAL xndowncase() { return (changecase('D',TRUE)); }
X
X/* changecase - change case */
XLOCAL LVAL changecase(fcn,destructive)
X  int fcn,destructive;
X{
X    unsigned char *srcp,*dstp;
X    int start,end,len,ch,i;
X    LVAL src,dst;
X
X    /* get the string */
X    src = xlgastring();
X
X    /* get the substring specifiers */
X    getbounds(src,k_start,k_end,&start,&end);
X    len = getslength(src) - 1;
X
X    /* make a destination string */
X    dst = (destructive ? src : newstring(len+1));
X
X    /* setup the string pointers */
X    srcp = getstring(src);
X    dstp = getstring(dst);
X
X    /* copy the source to the destination */
X    for (i = 0; i < len; ++i) {
X    ch = *srcp++;
X    if (i >= start && i < end)
X        switch (fcn) {
X        case 'U':    if (islower(ch)) ch = toupper(ch); break;
X        case 'D':    if (isupper(ch)) ch = tolower(ch); break;
X        }
X    *dstp++ = ch;
X    }
X    *dstp = '\0';
X
X    /* return the new string */
X    return (dst);
X}
X
X/* trim functions */
XLVAL xtrim()      { return (trim(TLEFT|TRIGHT)); }
XLVAL xlefttrim()  { return (trim(TLEFT)); }
XLVAL xrighttrim() { return (trim(TRIGHT)); }
X
X/* trim - trim character from a string */
XLOCAL LVAL trim(fcn)
X  int fcn;
X{
X    unsigned char *leftp,*rightp,*dstp;
X    LVAL bag,src,dst;
X
X    /* get the bag and the string */
X    bag = xlgastring();
X    src = xlgastring();
X    xllastarg();
X
X    /* setup the string pointers */
X    leftp = getstring(src);
X    rightp = leftp + getslength(src) - 2;
X
X    /* trim leading characters */
X    if (fcn & TLEFT)
X    while (leftp <= rightp && inbag(*leftp,bag))
X        ++leftp;
X
X    /* trim character from the right */
X    if (fcn & TRIGHT)
X    while (rightp >= leftp && inbag(*rightp,bag))
X        --rightp;
X
X    /* make a destination string and setup the pointer */
X    dst = newstring((int)(rightp-leftp+2));
X    dstp = getstring(dst);
X
X    /* copy the source to the destination */
X    while (leftp <= rightp)
X    *dstp++ = *leftp++;
X    *dstp = '\0';
X
X    /* return the new string */
X    return (dst);
X}
X
X/* getbounds - get the start and end bounds of a string */
XLOCAL getbounds(str,skey,ekey,pstart,pend)
X  LVAL str,skey,ekey; int *pstart,*pend;
X{
X    LVAL arg;
X    int len;
X
X    /* get the length of the string */
X    len = getslength(str) - 1;
X
X    /* get the starting index */
X    if (xlgkfixnum(skey,&arg)) {
X    *pstart = (int)getfixnum(arg);
X    if (*pstart < 0 || *pstart > len)
X        xlerror("string index out of bounds",arg);
X    }
X    else
X    *pstart = 0;
X
X    /* get the ending index */
X    if (xlgkfixnum(ekey,&arg)) {
X    *pend = (int)getfixnum(arg);
X    if (*pend < 0 || *pend > len)
X        xlerror("string index out of bounds",arg);
X    }
X    else
X    *pend = len;
X
X    /* make sure the start is less than or equal to the end */
X    if (*pstart > *pend)
X    xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
X}
X
X/* inbag - test if a character is in a bag */
XLOCAL int inbag(ch,bag)
X  int ch; LVAL bag;
X{
X    unsigned char *p;
X    for (p = getstring(bag); *p != '\0'; ++p)
X    if (*p == ch)
X        return (TRUE);
X    return (FALSE);
X}
X
X/* xstrcat - concatenate a bunch of strings */
XLVAL xstrcat()
X{
X    LVAL *saveargv,tmp,val;
X    unsigned char *str;
X    int saveargc,len;
X
X    /* save the argument list */
X    saveargv = xlargv;
X    saveargc = xlargc;
X
X    /* find the length of the new string */
X    for (len = 0; moreargs(); ) {
X    tmp = xlgastring();
X    len += (int)getslength(tmp) - 1;
X    }
X
X    /* create the result string */
X    val = newstring(len+1);
X    str = getstring(val);
X
X    /* restore the argument list */
X    xlargv = saveargv;
X    xlargc = saveargc;
X
X    /* combine the strings */
X    for (*str = '\0'; moreargs(); ) {
X    tmp = nextarg();
X    strcat(str,getstring(tmp));
X    }
X
X    /* return the new string */
X    return (val);
X}
X
X/* xsubseq - return a subsequence */
XLVAL xsubseq()
X{
X    unsigned char *srcp,*dstp;
X    int start,end,len;
X    LVAL src,dst;
X
X    /* get string and starting and ending positions */
X    src = xlgastring();
X
X    /* get the starting position */
X    dst = xlgafixnum(); start = (int)getfixnum(dst);
X    if (start < 0 || start > getslength(src) - 1)
X    xlerror("string index out of bounds",dst);
X
X    /* get the ending position */
X    if (moreargs()) {
X    dst = xlgafixnum(); end = (int)getfixnum(dst);
X    if (end < 0 || end > getslength(src) - 1)
X        xlerror("string index out of bounds",dst);
X    }
X    else
X    end = getslength(src) - 1;
X    xllastarg();
X
X    /* setup the source pointer */
X    srcp = getstring(src) + start;
X    len = end - start;
X
X    /* make a destination string and setup the pointer */
X    dst = newstring(len+1);
X    dstp = getstring(dst);
X
X    /* copy the source to the destination */
X    while (--len >= 0)
X    *dstp++ = *srcp++;
X    *dstp = '\0';
X
X    /* return the substring */
X    return (dst);
X}
X
X/* xstring - return a string consisting of a single character */
XLVAL xstring()
X{
X    LVAL arg;
X
X    /* get the argument */
X    arg = xlgetarg();
X    xllastarg();
X
X    /* make sure its not NIL */
X    if (null(arg))
X    xlbadtype(arg);
X
X    /* check the argument type */
X    switch (ntype(arg)) {
X    case STRING:
X    return (arg);
X    case SYMBOL:
X    return (getpname(arg));
X    case CHAR:
X    buf[0] = (int)getchcode(arg);
X    buf[1] = '\0';
X    return (cvstring(buf));
X    default:
X    xlbadtype(arg);
X    }
X}
X
X/* xchar - extract a character from a string */
XLVAL xchar()
X{
X    LVAL str,num;
X    int n;
X
X    /* get the string and the index */
X    str = xlgastring();
X    num = xlgafixnum();
X    xllastarg();
X
X    /* range check the index */
X    if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
X    xlerror("index out of range",num);
X
X    /* return the character */
X    return (cvchar(getstring(str)[n]));
X}
X
X/* xcharint - convert an integer to a character */
XLVAL xcharint()
X{
X    LVAL arg;
X    arg = xlgachar();
X    xllastarg();
X    return (cvfixnum((FIXTYPE)getchcode(arg)));
X}
X
X/* xintchar - convert a character to an integer */
XLVAL xintchar()
X{
X    LVAL arg;
X    arg = xlgafixnum();
X    xllastarg();
X    return (cvchar((int)getfixnum(arg)));
X}
X
X/* xuppercasep - built-in function 'upper-case-p' */
XLVAL xuppercasep()
X{
X    int ch;
X    ch = getchcode(xlgachar());
X    xllastarg();
X    return (isupper(ch) ? true : NIL);
X}
X
X/* xlowercasep - built-in function 'lower-case-p' */
XLVAL xlowercasep()
X{
X    int ch;
X    ch = getchcode(xlgachar());
X    xllastarg();
X    return (islower(ch) ? true : NIL);
X}
X
X/* xbothcasep - built-in function 'both-case-p' */
XLVAL xbothcasep()
X{
X    int ch;
X    ch = getchcode(xlgachar());
X    xllastarg();
X    return (isupper(ch) || islower(ch) ? true : NIL);
X}
X
X/* xdigitp - built-in function 'digit-char-p' */
XLVAL xdigitp()
X{
X    int ch;
X    ch = getchcode(xlgachar());
X    xllastarg();
X    return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL);
X}
X
X/* xcharcode - built-in function 'char-code' */
XLVAL xcharcode()
X{
X    int ch;
X    ch = getchcode(xlgachar());
X    xllastarg();
X    return (cvfixnum((FIXTYPE)ch));
X}
X
X/* xcodechar - built-in function 'code-char' */
XLVAL xcodechar()
X{
X    LVAL arg;
X    int ch;
X    arg = xlgafixnum(); ch = getfixnum(arg);
X    xllastarg();
X    return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL);
X}
X
X/* xchupcase - built-in function 'char-upcase' */
XLVAL xchupcase()
X{
X    LVAL arg;
X    int ch;
X    arg = xlgachar(); ch = getchcode(arg);
X    xllastarg();
X    return (islower(ch) ? cvchar(toupper(ch)) : arg);
X}
X
X/* xchdowncase - built-in function 'char-downcase' */
XLVAL xchdowncase()
X{
X    LVAL arg;
X    int ch;
X    arg = xlgachar(); ch = getchcode(arg);
X    xllastarg();
X    return (isupper(ch) ? cvchar(tolower(ch)) : arg);
X}
X
X/* xdigitchar - built-in function 'digit-char' */
XLVAL xdigitchar()
X{
X    LVAL arg;
X    int n;
X    arg = xlgafixnum(); n = getfixnum(arg);
X    xllastarg();
X    return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL);
X}
X
X/* xalphanumericp - built-in function 'alphanumericp' */
XLVAL xalphanumericp()
X{
X    int ch;
X    ch = getchcode(xlgachar());
X    xllastarg();
X    return (isupper(ch) || islower(ch) || isdigit(ch) ? true : NIL);
X}
X
X/* character comparision functions */
XLVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char< */
XLVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<= */
XLVAL xchreql() { return (chrcompare('=',FALSE)); } /* char= */
XLVAL xchrneq() { return (chrcompare('#',FALSE)); } /* char/= */
XLVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>= */
XLVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char> */
X
X/* character comparision functions (case insensitive) */
XLVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-lessp */
XLVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-not-greaterp */
XLVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-equalp */
XLVAL xchrineq() { return (chrcompare('#',TRUE)); } /* char-not-equalp */
XLVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-not-lessp */
XLVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-greaterp */
X
X/* chrcompare - compare characters */
XLOCAL LVAL chrcompare(fcn,icase)
X  int fcn,icase;
X{
X    int ch1,ch2,icmp;
X    LVAL arg;
X
X    /* get the characters */
X    arg = xlgachar(); ch1 = getchcode(arg);
X
X    /* convert to lowercase if case insensitive */
X    if (icase && isupper(ch1))
X    ch1 = tolower(ch1);
X
X    /* handle each remaining argument */
X    for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) {
X
X    /* get the next argument */
X    arg = xlgachar(); ch2 = getchcode(arg);
X
X    /* convert to lowercase if case insensitive */
X    if (icase && isupper(ch2))
X        ch2 = tolower(ch2);
X
X    /* compare the characters */
X    switch (fcn) {
X    case '<':    icmp = (ch1 < ch2); break;
X    case 'L':    icmp = (ch1 <= ch2); break;
X    case '=':    icmp = (ch1 == ch2); break;
X    case '#':    icmp = (ch1 != ch2); break;
X    case 'G':    icmp = (ch1 >= ch2); break;
X    case '>':    icmp = (ch1 > ch2); break;
X    }
X    }
X
X    /* return the result */
X    return (icmp ? true : NIL);
X}
X
SHAR_EOF
if test 13099 -ne "`wc -c 'xlstr.c'`"
then
    echo shar: error transmitting "'xlstr.c'" '(should have been 13099 characters)'
fi
echo shar: extracting "'xlstruct.c'" '(10906 characters)'
if test -f 'xlstruct.c'
then
    echo shar: over-writing existing file "'xlstruct.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlstruct.c'
X/* xlstruct.c - the defstruct facility */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv;
Xextern LVAL s_lambda,s_quote,lk_key,true;
Xextern char buf[];
X
X/* local variables */
Xstatic prefix[STRMAX+1];
X
X/* xmkstruct - the '%make-struct' function */
XLVAL xmkstruct()
X{
X    LVAL type,val;
X    int i;
X
X    /* get the structure type */
X    type = xlgasymbol();
X
X    /* make the structure */
X    val = newstruct(type,xlargc);
X
X    /* store each argument */
X    for (i = 1; moreargs(); ++i)
X    setelement(val,i,nextarg());
X    xllastarg();
X
X    /* return the structure */
X    return (val);
X}
X
X/* xcpystruct - the '%copy-struct' function */
XLVAL xcpystruct()
X{
X    LVAL str,val;
X    int size,i;
X    str = xlgastruct();
X    xllastarg();
X    size = getsize(str);
X    val = newstruct(getelement(str,0),size-1);
X    for (i = 1; i < size; ++i)
X    setelement(val,i,getelement(str,i));
X    return (val);
X}
X
X/* xstrref - the '%struct-ref' function */
XLVAL xstrref()
X{
X    LVAL str,val;
X    int i;
X    str = xlgastruct();
X    val = xlgafixnum(); i = (int)getfixnum(val);
X    xllastarg();
X    return (getelement(str,i));
X}
X
X/* xstrset - the '%struct-set' function */
XLVAL xstrset()
X{
X    LVAL str,val;
X    int i;
X    str = xlgastruct();
X    val = xlgafixnum(); i = (int)getfixnum(val);
X    val = xlgetarg();
X    xllastarg();
X    setelement(str,i,val);
X    return (val);
X}
X
X/* xstrtypep - the '%struct-type-p' function */
XLVAL xstrtypep()
X{
X    LVAL type,val;
X    type = xlgasymbol();
X    val = xlgetarg();
X    xllastarg();
X    return (structp(val) && getelement(val,0) == type ? true : NIL);
X}
X
X/* xdefstruct - the 'defstruct' special form */
XLVAL xdefstruct()
X{
X    LVAL structname,slotname,defexpr,sym,tmp,args,body;
X    LVAL options,oargs,slots;
X    char *pname;
X    int slotn;
X
X    /* protect some pointers */
X    xlstkcheck(6);
X    xlsave(structname);
X    xlsave(slotname);
X    xlsave(defexpr);
X    xlsave(args);
X    xlsave(body);
X    xlsave(tmp);
X
X    /* initialize */
X    args = body = NIL;
X    slotn = 0;
X
X    /* get the structure name */
X    tmp = xlgetarg();
X    if (symbolp(tmp)) {
X    structname = tmp;
X    strcpy(prefix,getstring(getpname(structname)));
X    strcat(prefix,"-");
X    }
X
X    /* get the structure name and options */
X    else if (consp(tmp) && symbolp(car(tmp))) {
X    structname = car(tmp);
X    strcpy(prefix,getstring(getpname(structname)));
X    strcat(prefix,"-");
X
X    /* handle the list of options */
X    for (options = cdr(tmp); consp(options); options = cdr(options)) {
X
X        /* get the next argument */
X        tmp = car(options);
X
X        /* handle options that don't take arguments */
X        if (symbolp(tmp)) {
X        pname = getstring(getpname(tmp));
X        xlerror("unknown option",tmp);
X        }
X
X        /* handle options that take arguments */
X        else if (consp(tmp) && symbolp(car(tmp))) {
X        pname = getstring(getpname(car(tmp)));
X        oargs = cdr(tmp);
X
X        /* check for the :CONC-NAME keyword */
X        if (strcmp(pname,":CONC-NAME") == 0) {
X
X            /* get the name of the structure to include */
X            if (!consp(oargs) || !symbolp(car(oargs)))
X            xlerror("expecting a symbol",oargs);
X
X            /* save the prefix */
X            strcpy(prefix,getstring(getpname(car(oargs))));
X        }
X
X        /* check for the :INCLUDE keyword */
X        else if (strcmp(pname,":INCLUDE") == 0) {
X
X            /* get the name of the structure to include */
X            if (!consp(oargs) || !symbolp(car(oargs)))
X            xlerror("expecting a structure name",oargs);
X            tmp = car(oargs);
X            oargs = cdr(oargs);
X
X            /* add each slot from the included structure */
X            slots = xlgetprop(tmp,xlenter("*STRUCT-SLOTS*"));
X            for (; consp(slots); slots = cdr(slots)) {
X            if (consp(car(slots)) && consp(cdr(car(slots)))) {
X
X                /* get the next slot description */
X                tmp = car(slots);
X
X                /* create the slot access functions */
X                addslot(car(tmp),car(cdr(tmp)),++slotn,&args,&body);
X            }
X            }
X
X            /* handle slot initialization overrides */
X            for (; consp(oargs); oargs = cdr(oargs)) {
X            tmp = car(oargs);
X            if (symbolp(tmp)) {
X                slotname = tmp;
X                defexpr = NIL;
X            }
X            else if (consp(tmp) && symbolp(car(tmp))) {
X                slotname = car(tmp);
X                defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
X            }
X            else
X                xlerror("bad slot description",tmp);
X            updateslot(args,slotname,defexpr);
X            }
X        }
X        else
X            xlerror("unknown option",tmp);
X        }
X        else
X        xlerror("bad option syntax",tmp);
X    }
X    }
X
X    /* get each of the structure members */
X    while (moreargs()) {
X
X    /* get the slot name and default value expression */
X    tmp = xlgetarg();
X    if (symbolp(tmp)) {
X        slotname = tmp;
X        defexpr = NIL;
X    }
X    else if (consp(tmp) && symbolp(car(tmp))) {
X        slotname = car(tmp);
X        defexpr = (consp(cdr(tmp)) ? car(cdr(tmp)) : NIL);
X    }
X    else
X        xlerror("bad slot description",tmp);
X
X    /* create a closure for non-trival default expressions */
X    if (defexpr != NIL) {
X        tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
X        setbody(tmp,cons(defexpr,NIL));
X        tmp = cons(tmp,NIL);
X        defexpr = tmp;
X    }
X
X    /* create the slot access functions */
X    addslot(slotname,defexpr,++slotn,&args,&body);
X    }
X
X    /* store the slotnames and default expressions */
X    xlputprop(structname,args,xlenter("*STRUCT-SLOTS*"));
X
X    /* enter the MAKE-xxx symbol */
X    sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
X    sym = xlenter(buf);
X
X    /* make the MAKE-xxx function */
X    args = cons(lk_key,args);
X    tmp = cons(structname,NIL);
X    tmp = cons(s_quote,tmp);
X    body = cons(tmp,body);
X    body = cons(xlenter("%MAKE-STRUCT"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,xlenv,xlfenv));
X
X    /* enter the xxx-P symbol */
X    sprintf(buf,"%s-P",getstring(getpname(structname)));
X    sym = xlenter(buf);
X
X    /* make the xxx-P function */
X    args = cons(xlenter("X"),NIL);
X    body = cons(xlenter("X"),NIL);
X    tmp = cons(structname,NIL);
X    tmp = cons(s_quote,tmp);
X    body = cons(tmp,body);
X    body = cons(xlenter("%STRUCT-TYPE-P"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X    /* enter the COPY-xxx symbol */
X    sprintf(buf,"COPY-%s",getstring(getpname(structname)));
X    sym = xlenter(buf);
X
X    /* make the COPY-xxx function */
X    args = cons(xlenter("X"),NIL);
X    body = cons(xlenter("X"),NIL);
X    body = cons(xlenter("%COPY-STRUCT"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X    /* restore the stack */
X    xlpopn(6);
X
X    /* return the structure name */
X    return (structname);
X}
X
X/* xlrdstruct - convert a list to a structure (used by the reader) */
XLVAL xlrdstruct(list)
X  LVAL list;
X{
X    LVAL structname,sym,slotname,expr,last,val;
X
X    /* protect the new structure */
X    xlsave1(expr);
X
X    /* get the structure name */
X    if (!consp(list) || !symbolp(car(list)))
X    xlerror("bad structure initialization list",list);
X    structname = car(list);
X    list = cdr(list);
X
X    /* enter the MAKE-xxx symbol */
X    sprintf(buf,"MAKE-%s",getstring(getpname(structname)));
X
X    /* initialize the MAKE-xxx function call expression */
X    expr = cons(xlenter(buf),NIL);
X    last = expr;
X
X    /* turn the rest of the initialization list into keyword arguments */
X    while (consp(list) && consp(cdr(list))) {
X
X    /* get the slot keyword name */
X    slotname = car(list);
X    if (!symbolp(slotname))
X        xlerror("expecting a slot name",slotname);
X    sprintf(buf,":%s",getstring(getpname(slotname)));
X
X    /* add the slot keyword */
X    rplacd(last,cons(xlenter(buf),NIL));
X    last = cdr(last);
X    list = cdr(list);
X
X    /* add the value expression */
X    rplacd(last,cons(car(list),NIL));
X    last = cdr(last);
X    list = cdr(list);
X    }
X
X    /* make sure all of the initializers were used */
X    if (consp(list))
X    xlerror("bad structure initialization list",list);
X
X    /* invoke the creation function */
X    val = xleval(expr);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new structure */
X    return (val);
X}
X
X/* xlprstruct - print a structure (used by printer) */
Xxlprstruct(fptr,vptr,flag)
X  LVAL fptr,vptr; int flag;
X{
X    LVAL next;
X    int i,n;
X    xlputc(fptr,'#'); xlputc(fptr,'S'); xlputc(fptr,'(');
X    xlprint(fptr,getelement(vptr,0),flag);
X    next = xlgetprop(getelement(vptr,0),xlenter("*STRUCT-SLOTS*"));
X    for (i = 1, n = getsize(vptr) - 1; i <= n && consp(next); ++i) {
X    if (consp(car(next))) { /* should always succeed */
X        xlputc(fptr,' ');
X        xlprint(fptr,car(car(next)),flag);
X        xlputc(fptr,' ');
X        xlprint(fptr,getelement(vptr,i),flag);
X    }
X    next = cdr(next);
X    }
X    xlputc(fptr,')');
X}
X
X/* addslot - make the slot access functions */
XLOCAL addslot(slotname,defexpr,slotn,pargs,pbody)
X  LVAL slotname,defexpr; int slotn; LVAL *pargs,*pbody;
X{
X    LVAL sym,args,body,tmp;
X
X    /* protect some pointers */
X    xlstkcheck(4);
X    xlsave(sym);
X    xlsave(args);
X    xlsave(body);
X    xlsave(tmp);
X
X    /* construct the update function name */
X    sprintf(buf,"%s%s",prefix,getstring(getpname(slotname)));
X    sym = xlenter(buf);
X
X    /* make the access function */
X    args = cons(xlenter("S"),NIL);
X    body = cons(cvfixnum((FIXTYPE)slotn),NIL);
X    body = cons(xlenter("S"),body);
X    body = cons(xlenter("%STRUCT-REF"),body);
X    body = cons(body,NIL);
X    setfunction(sym,
X        xlclose(sym,s_lambda,args,body,NIL,NIL));
X
X    /* make the update function */
X    args = cons(xlenter("V"),NIL);
X    args = cons(xlenter("S"),args);
X    body = cons(xlenter("V"),NIL);
X    body = cons(cvfixnum((FIXTYPE)slotn),body);
X    body = cons(xlenter("S"),body);
X    body = cons(xlenter("%STRUCT-SET"),body);
X    body = cons(body,NIL);
X    xlputprop(sym,
X          xlclose(NIL,s_lambda,args,body,NIL,NIL),
X          xlenter("*SETF*"));
X
X    /* add the slotname to the make-xxx keyword list */
X    tmp = cons(defexpr,NIL);
X    tmp = cons(slotname,tmp);
X    tmp = cons(tmp,NIL);
X    if ((args = *pargs) == NIL)
X    *pargs = tmp;
X    else {
X    while (cdr(args) != NIL)
X        args = cdr(args);
X    rplacd(args,tmp);
X    }
X
X    /* add the slotname to the %make-xxx argument list */
X    tmp = cons(slotname,NIL);
X    if ((body = *pbody) == NIL)
X    *pbody = tmp;
X    else {
X    while (cdr(body) != NIL)
X        body = cdr(body);
X    rplacd(body,tmp);
X    }
X
X    /* restore the stack */
X    xlpopn(4);
X}
X
X/* updateslot - update a slot definition */
XLOCAL updateslot(args,slotname,defexpr)
X  LVAL args,slotname,defexpr;
X{
X    LVAL tmp;
X    for (; consp(args); args = cdr(args))
X    if (slotname == car(car(args))) {
X        if (defexpr != NIL) {
X        xlsave1(tmp);
X        tmp = newclosure(NIL,s_lambda,xlenv,xlfenv);
X        setbody(tmp,cons(defexpr,NIL));
X        tmp = cons(tmp,NIL);
X        defexpr = tmp;
X        xlpop();
X        }
X        rplaca(cdr(car(args)),defexpr);
X        break;
X    }
X    if (args == NIL)
X    xlerror("unknown slot name",slotname);
X}
X
SHAR_EOF
if test 10906 -ne "`wc -c 'xlstruct.c'`"
then
    echo shar: error transmitting "'xlstruct.c'" '(should have been 10906 characters)'
fi
echo shar: extracting "'xlsubr.c'" '(3858 characters)'
if test -f 'xlsubr.c'
then
    echo shar: over-writing existing file "'xlsubr.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsubr.c'
X/* xlsubr - xlisp builtin function support routines */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL k_test,k_tnot,s_eql;
X
X/* xlsubr - define a builtin function */
XLVAL xlsubr(sname,type,fcn,offset)
X  char *sname; int type; LVAL (*fcn)(); int offset;
X{
X    LVAL sym;
X    sym = xlenter(sname);
X    setfunction(sym,cvsubr(fcn,type,offset));
X    return (sym);
X}
X
X/* xlgetkeyarg - get a keyword argument */
Xint xlgetkeyarg(key,pval)
X  LVAL key,*pval;
X{
X    LVAL *argv=xlargv;
X    int argc=xlargc;
X    for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
X    if (*argv == key) {
X        *pval = *++argv;
X        return (TRUE);
X    }
X    }
X    return (FALSE);
X}
X
X/* xlgkfixnum - get a fixnum keyword argument */
Xint xlgkfixnum(key,pval)
X  LVAL key,*pval;
X{
X    if (xlgetkeyarg(key,pval)) {
X    if (!fixp(*pval))
X        xlbadtype(*pval);
X    return (TRUE);
X    }
X    return (FALSE);
X}
X
X/* xltest - get the :test or :test-not keyword argument */
Xxltest(pfcn,ptresult)
X  LVAL *pfcn; int *ptresult;
X{
X    if (xlgetkeyarg(k_test,pfcn))    /* :test */
X    *ptresult = TRUE;
X    else if (xlgetkeyarg(k_tnot,pfcn))    /* :test-not */
X    *ptresult = FALSE;
X    else {
X    *pfcn = getfunction(s_eql);
X    *ptresult = TRUE;
X    }
X}
X
X/* xlgetfile - get a file or stream */
XLVAL xlgetfile()
X{
X    LVAL arg;
X
X    /* get a file or stream (cons) or nil */
X    if (arg = xlgetarg()) {
X    if (streamp(arg)) {
X        if (getfile(arg) == NULL)
X        xlfail("file not open");
X    }
X    else if (!ustreamp(arg))
X        xlerror("bad argument type",arg);
X    }
X    return (arg);
X}
X
X/* xlgetfname - get a filename */
XLVAL xlgetfname()
X{
X    LVAL name;
X
X    /* get the next argument */
X    name = xlgetarg();
X
X    /* get the filename string */
X    if (symbolp(name))
X    name = getpname(name);
X    else if (!stringp(name))
X    xlerror("bad argument type",name);
X
X    /* return the name */
X    return (name);
X}
X
X/* needsextension - check if a filename needs an extension */
Xint needsextension(name)
X  char *name;
X{
X    char *p;
X
X    /* check for an extension */
X    for (p = &name[strlen(name)]; --p >= &name[0]; )
X    if (*p == '.')
X        return (FALSE);
X    else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
X        return (TRUE);
X
X    /* no extension found */
X    return (TRUE);
X}
X
X/* xlbadtype - report a "bad argument type" error */
XLVAL xlbadtype(arg)
X  LVAL arg;
X{
X    xlerror("bad argument type",arg);
X}
X
X/* xltoofew - report a "too few arguments" error */
XLVAL xltoofew()
X{
X    xlfail("too few arguments");
X}
X
X/* xltoomany - report a "too many arguments" error */
Xxltoomany()
X{
X    xlfail("too many arguments");
X}
X
X/* eq - internal eq function */
Xint eq(arg1,arg2)
X  LVAL arg1,arg2;
X{
X    return (arg1 == arg2);
X}
X
X/* eql - internal eql function */
Xint eql(arg1,arg2)
X  LVAL arg1,arg2;
X{
X    /* compare the arguments */
X    if (arg1 == arg2)
X    return (TRUE);
X    else if (arg1) {
X    switch (ntype(arg1)) {
X    case FIXNUM:
X        return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
X    case FLONUM:
X        return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
X    default:
X        return (FALSE);
X    }
X    }
X    else
X    return (FALSE);
X}
X
X/* equal - internal equal function */
Xint equal(arg1,arg2)
X  LVAL arg1,arg2;
X{
X    /* compare the arguments */
X    if (arg1 == arg2)
X    return (TRUE);
X    else if (arg1) {
X    switch (ntype(arg1)) {
X    case FIXNUM:
X        return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
X    case FLONUM:
X        return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
X    case STRING:
X        return (stringp(arg2) ? strcmp(getstring(arg1),
X                       getstring(arg2)) == 0 : FALSE);
X    case CONS:
X        return (consp(arg2) ? equal(car(arg1),car(arg2))
X                   && equal(cdr(arg1),cdr(arg2)) : FALSE);
X    default:
X        return (FALSE);
X    }
X    }
X    else
X    return (FALSE);
X}
SHAR_EOF
if test 3858 -ne "`wc -c 'xlsubr.c'`"
then
    echo shar: error transmitting "'xlsubr.c'" '(should have been 3858 characters)'
fi
echo shar: extracting "'xlsym.c'" '(5057 characters)'
if test -f 'xlsym.c'
then
    echo shar: over-writing existing file "'xlsym.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsym.c'
X/* xlsym - symbol handling routines */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL obarray,s_unbound;
Xextern LVAL xlenv,xlfenv,xldenv;
X
X/* forward declarations */
XFORWARD LVAL findprop();
X
X/* xlenter - enter a symbol into the obarray */
XLVAL xlenter(name)
X  char *name;
X{
X    LVAL sym,array;
X    int i;
X
X    /* check for nil */
X    if (strcmp(name,"NIL") == 0)
X    return (NIL);
X
X    /* check for symbol already in table */
X    array = getvalue(obarray);
X    i = hash(name,HSIZE);
X    for (sym = getelement(array,i); sym; sym = cdr(sym))
X    if (strcmp(name,getstring(getpname(car(sym)))) == 0)
X        return (car(sym));
X
X    /* make a new symbol node and link it into the list */
X    xlsave1(sym);
X    sym = consd(getelement(array,i));
X    rplaca(sym,xlmakesym(name));
X    setelement(array,i,sym);
X    xlpop();
X
X    /* return the new symbol */
X    return (car(sym));
X}
X
X/* xlmakesym - make a new symbol node */
XLVAL xlmakesym(name)
X  char *name;
X{
X    LVAL sym;
X    sym = cvsymbol(name);
X    if (*name == ':')
X    setvalue(sym,sym);
X    return (sym);
X}
X
X/* xlgetvalue - get the value of a symbol (with check) */
XLVAL xlgetvalue(sym)
X  LVAL sym;
X{
X    LVAL val;
X
X    /* look for the value of the symbol */
X    while ((val = xlxgetvalue(sym)) == s_unbound)
X    xlunbound(sym);
X
X    /* return the value */
X    return (val);
X}
X
X/* xlxgetvalue - get the value of a symbol */
XLVAL xlxgetvalue(sym)
X  LVAL sym;
X{
X    register LVAL fp,ep;
X    LVAL val;
X
X    /* check the environment list */
X    for (fp = xlenv; fp; fp = cdr(fp))
X
X    /* check for an instance variable */
X    if ((ep = car(fp)) && objectp(car(ep))) {
X        if (xlobgetvalue(ep,sym,&val))
X        return (val);
X    }
X
X    /* check an environment stack frame */
X    else {
X        for (; ep; ep = cdr(ep))
X        if (sym == car(car(ep)))
X            return (cdr(car(ep)));
X    }
X
X    /* return the global value */
X    return (getvalue(sym));
X}
X
X/* xlsetvalue - set the value of a symbol */
Xxlsetvalue(sym,val)
X  LVAL sym,val;
X{
X    register LVAL fp,ep;
X
X    /* look for the symbol in the environment list */
X    for (fp = xlenv; fp; fp = cdr(fp))
X
X    /* check for an instance variable */
X    if ((ep = car(fp)) && objectp(car(ep))) {
X        if (xlobsetvalue(ep,sym,val))
X        return;
X    }
X
X    /* check an environment stack frame */
X    else {
X        for (; ep; ep = cdr(ep))
X        if (sym == car(car(ep))) {
X            rplacd(car(ep),val);
X            return;
X        }
X    }
X
X    /* store the global value */
X    setvalue(sym,val);
X}
X
X/* xlgetfunction - get the functional value of a symbol (with check) */
XLVAL xlgetfunction(sym)
X  LVAL sym;
X{
X    LVAL val;
X
X    /* look for the functional value of the symbol */
X    while ((val = xlxgetfunction(sym)) == s_unbound)
X    xlfunbound(sym);
X
X    /* return the value */
X    return (val);
X}
X
X/* xlxgetfunction - get the functional value of a symbol */
XLVAL xlxgetfunction(sym)
X  LVAL sym;
X{
X    register LVAL fp,ep;
X
X    /* check the environment list */
X    for (fp = xlfenv; fp; fp = cdr(fp))
X    for (ep = car(fp); ep; ep = cdr(ep))
X        if (sym == car(car(ep)))
X        return (cdr(car(ep)));
X
X    /* return the global value */
X    return (getfunction(sym));
X}
X
X/* xlsetfunction - set the functional value of a symbol */
Xxlsetfunction(sym,val)
X  LVAL sym,val;
X{
X    register LVAL fp,ep;
X
X    /* look for the symbol in the environment list */
X    for (fp = xlfenv; fp; fp = cdr(fp))
X    for (ep = car(fp); ep; ep = cdr(ep))
X        if (sym == car(car(ep))) {
X        rplacd(car(ep),val);
X        return;
X        }
X
X    /* store the global value */
X    setfunction(sym,val);
X}
X
X/* xlgetprop - get the value of a property */
XLVAL xlgetprop(sym,prp)
X  LVAL sym,prp;
X{
X    LVAL p;
X    return ((p = findprop(sym,prp)) ? car(p) : NIL);
X}
X
X/* xlputprop - put a property value onto the property list */
Xxlputprop(sym,val,prp)
X  LVAL sym,val,prp;
X{
X    LVAL pair;
X    if (pair = findprop(sym,prp))
X    rplaca(pair,val);
X    else
X    setplist(sym,cons(prp,cons(val,getplist(sym))));
X}
X
X/* xlremprop - remove a property from a property list */
Xxlremprop(sym,prp)
X  LVAL sym,prp;
X{
X    LVAL last,p;
X    last = NIL;
X    for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
X    if (car(p) == prp)
X        if (last)
X        rplacd(last,cdr(cdr(p)));
X        else
X        setplist(sym,cdr(cdr(p)));
X    last = cdr(p);
X    }
X}
X
X/* findprop - find a property pair */
XLOCAL LVAL findprop(sym,prp)
X  LVAL sym,prp;
X{
X    LVAL p;
X    for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X    if (car(p) == prp)
X        return (cdr(p));
X    return (NIL);
X}
X
X/* hash - hash a symbol name string */
Xint hash(str,len)
X  char *str;
X{
X    int i;
X    for (i = 0; *str; )
X    i = (i << 2) ^ *str++;
X    i %= len;
X    return (i < 0 ? -i : i);
X}
X
X/* xlsinit - symbol initialization routine */
Xxlsinit()
X{
X    LVAL array,p;
X
X    /* initialize the obarray */
X    obarray = xlmakesym("*OBARRAY*");
X    array = newvector(HSIZE);
X    setvalue(obarray,array);
X
X    /* add the symbol *OBARRAY* to the obarray */
X    p = consa(obarray);
X    setelement(array,hash("*OBARRAY*",HSIZE),p);
X}
SHAR_EOF
if test 5057 -ne "`wc -c 'xlsym.c'`"
then
    echo shar: error transmitting "'xlsym.c'" '(should have been 5057 characters)'
fi
echo shar: extracting "'xlsys.c'" '(3335 characters)'
if test -f 'xlsys.c'
then
    echo shar: over-writing existing file "'xlsys.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlsys.c'
X/* xlsys.c - xlisp builtin system functions */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern jmp_buf top_level;
Xextern FILE *tfp;
X
X/* external symbols */
Xextern LVAL a_subr,a_fsubr,a_cons,a_symbol;
Xextern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
Xextern LVAL a_vector,a_closure,a_char,a_ustream;
Xextern LVAL k_verbose,k_print;
Xextern LVAL true;
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* xload - read and evaluate expressions from a file */
XLVAL xload()
X{
X    unsigned char *name;
X    int vflag,pflag;
X    LVAL arg;
X
X    /* get the file name */
X    name = getstring(xlgetfname());
X
X    /* get the :verbose flag */
X    if (xlgetkeyarg(k_verbose,&arg))
X    vflag = (arg != NIL);
X    else
X    vflag = TRUE;
X
X    /* get the :print flag */
X    if (xlgetkeyarg(k_print,&arg))
X    pflag = (arg != NIL);
X    else
X    pflag = FALSE;
X
X    /* load the file */
X    return (xlload(name,vflag,pflag) ? true : NIL);
X}
X
X/* xtranscript - open or close a transcript file */
XLVAL xtranscript()
X{
X    unsigned char *name;
X
X    /* get the transcript file name */
X    name = (moreargs() ? getstring(xlgetfname()) : NULL);
X    xllastarg();
X
X    /* close the current transcript */
X    if (tfp) osclose(tfp);
X
X    /* open the new transcript */
X    tfp = (name ? osaopen(name,"w") : NULL);
X
X    /* return T if a transcript is open, NIL otherwise */
X    return (tfp ? true : NIL);
X}
X
X/* xtype - return type of a thing */
XLVAL xtype()
X{
X    LVAL arg;
X
X    if (!(arg = xlgetarg()))
X    return (NIL);
X
X    switch (ntype(arg)) {
X    case SUBR:        return (a_subr);
X    case FSUBR:        return (a_fsubr);
X    case CONS:        return (a_cons);
X    case SYMBOL:    return (a_symbol);
X    case FIXNUM:    return (a_fixnum);
X    case FLONUM:    return (a_flonum);
X    case STRING:    return (a_string);
X    case OBJECT:    return (a_object);
X    case STREAM:    return (a_stream);
X    case VECTOR:    return (a_vector);
X    case CLOSURE:    return (a_closure);
X    case CHAR:        return (a_char);
X    case USTREAM:    return (a_ustream);
X    case STRUCT:    return (getelement(arg,0));
X    default:        xlfail("bad node type");
X    }
X}
X
X/* xbaktrace - print the trace back stack */
XLVAL xbaktrace()
X{
X    LVAL num;
X    int n;
X
X    if (moreargs()) {
X    num = xlgafixnum();
X    n = getfixnum(num);
X    }
X    else
X    n = -1;
X    xllastarg();
X    xlbaktrace(n);
X    return (NIL);
X}
X
X/* xexit - get out of xlisp */
XLVAL xexit()
X{
X    xllastarg();
X    wrapup();
X}
X
X/* xpeek - peek at a location in memory */
XLVAL xpeek()
X{
X    LVAL num;
X    int *adr;
X
X    /* get the address */
X    num = xlgafixnum(); adr = (int *)getfixnum(num);
X    xllastarg();
X
X    /* return the value at that address */
X    return (cvfixnum((FIXTYPE)*adr));
X}
X
X/* xpoke - poke a value into memory */
XLVAL xpoke()
X{
X    LVAL val;
X    int *adr;
X
X    /* get the address and the new value */
X    val = xlgafixnum(); adr = (int *)getfixnum(val);
X    val = xlgafixnum();
X    xllastarg();
X
X    /* store the new value */
X    *adr = (int)getfixnum(val);
X
X    /* return the new value */
X    return (val);
X}
X
X/* xaddrs - get the address of an XLISP node */
XLVAL xaddrs()
X{
X    LVAL val;
X
X    /* get the node */
X    val = xlgetarg();
X    xllastarg();
X
X    /* return the address of the node */
X    return (cvfixnum((FIXTYPE)val));
X}
X
SHAR_EOF
if test 3335 -ne "`wc -c 'xlsys.c'`"
then
    echo shar: error transmitting "'xlsys.c'" '(should have been 3335 characters)'
fi
#    End of shell archive
exit 0
--
Gary Murphy                   uunet!mitel!sce!cognos!garym
                              ([e-mail])
[phone] x5537          Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc